home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / arith.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-07-15  |  13.0 KB  |  576 lines
  1. /*
  2.   *
  3.   * New Number code
  4.   */
  5.  
  6. /* History:
  7.  * Created: 2/12/92
  8.  */
  9.  
  10.  
  11. #include "defs.h"
  12. #include "structs.h"
  13. #include "error.h"
  14. #include "funcalls.h"
  15. #include "modboot.h"
  16. #include "global.h"
  17. #include "ngenerics.h"
  18.  
  19. #include <math.h>
  20.  
  21. #define floatval(x) ((x)->FLOAT.fvalue)
  22. #define integerval(x) intval(x)
  23.  
  24. /* generics for n-ary functions */
  25. static LispObject generic_add;
  26. static LispObject generic_subtract;
  27. static LispObject generic_multiply;
  28. static LispObject generic_divide;
  29. static LispObject generic_lcm;
  30. static LispObject generic_gcd;
  31. static LispObject generic_lt;
  32. static LispObject generic_negate;
  33.  
  34. /* Integer Operations */
  35. EUFUN_2(Md_binary_add_Integer_Integer, a1,  a2)
  36. {
  37.   return (allocate_integer(stacktop,integerval(a1)+integerval(a2)));
  38. }
  39. EUFUN_CLOSE
  40.  
  41. EUFUN_2(Md_binary_subtract_Integer_Integer, a1,  a2)
  42. {
  43.   return (allocate_integer(stacktop,integerval(a1)-integerval(a2)));
  44. }
  45. EUFUN_CLOSE
  46.  
  47. EUFUN_2(Md_binary_multiply_Integer_Integer, a1,  a2)
  48. {
  49.   return (allocate_integer(stacktop,integerval(a1)*integerval(a2)));
  50. }
  51. EUFUN_CLOSE
  52.  
  53. EUFUN_2(Md_binary_divide_Integer_Integer, a1,  a2)
  54. {
  55.   if (integerval(a2))
  56.     return (allocate_integer(stacktop,integerval(a1)/integerval(a2)));
  57.   else
  58.     CallError(stacktop,"division by zero",a1,NONCONTINUABLE);
  59. }
  60. EUFUN_CLOSE
  61.  
  62. EUFUN_1(Md_negate_Integer, a1)
  63. {
  64.   return (allocate_integer(stacktop,-integerval(a1)));
  65. }
  66. EUFUN_CLOSE
  67.  
  68. EUFUN_2(Md_binary_lcm_Integer_Integer, n1,  n2)
  69. {
  70.   extern int abs(int);
  71.   int a,b,r,origa,origb;
  72.  
  73.   a = abs(intval(n1)); b = abs(intval(n2));
  74.   origa = a; origb = b;
  75.   do {
  76.     r = a%b;
  77.     a = b; b = r;
  78.   } while(b != 0);
  79.  
  80.   a = (origa/a)*origb;
  81.   return allocate_integer(stackbase, a);
  82. }
  83. EUFUN_CLOSE
  84.  
  85. EUFUN_2(Md_binary_gcd_Integer_Integer, n1,  n2)
  86. {
  87.   int a,b,r;
  88.   LispObject ans;
  89.  
  90.   a = abs(intval(n1)); b = abs(intval(n2));
  91.  
  92.   do {
  93.     
  94.     r = a%b;
  95.     a = b; b = r;
  96.  
  97.   } while(b != 0);
  98.  
  99.   return (LispObject) allocate_integer(stackbase, a);
  100. }
  101. EUFUN_CLOSE
  102.  
  103. EUFUN_2(Md_binary_lt_Integer_Integer, a1,  a2)
  104. {
  105.   if (integerval(a1)<integerval(a2))
  106.     return lisptrue;
  107.   else
  108.     return nil;
  109. }
  110. EUFUN_CLOSE
  111.  
  112. EUFUN_2(Md_binary_eqn_Integer_Integer, a1,  a2)
  113. {
  114.   if (integerval(a1)==integerval(a2))
  115.     return lisptrue;
  116.   else
  117.     return nil;
  118. }
  119. EUFUN_CLOSE
  120.  
  121.  
  122. /* Float Operations */
  123. EUFUN_2(Md_binary_add_Float_Float, a1,  a2)
  124. {
  125.   return (allocate_float(stacktop,floatval(a1)+floatval(a2)));
  126. }
  127. EUFUN_CLOSE
  128.  
  129. EUFUN_2(Md_binary_subtract_Float_Float, a1,  a2)
  130. {
  131.   return (allocate_float(stacktop,floatval(a1)-floatval(a2)));
  132. }
  133. EUFUN_CLOSE
  134.  
  135. EUFUN_2(Md_binary_multiply_Float_Float, a1,  a2)
  136. {
  137.   return (allocate_float(stacktop,floatval(a1)*floatval(a2)));
  138. }
  139. EUFUN_CLOSE
  140.  
  141. EUFUN_2(Md_binary_divide_Float_Float, a1,  a2)
  142. {
  143.   return (allocate_float(stacktop,floatval(a1)/floatval(a2)));
  144. }
  145. EUFUN_CLOSE
  146.  
  147. EUFUN_2(Md_binary_lt_Float_Float, a1,  a2)
  148. {
  149.   if (floatval(a1)<floatval(a2))
  150.     return lisptrue;
  151.   else
  152.     return nil;
  153. }
  154. EUFUN_CLOSE
  155.  
  156. EUFUN_2(Md_binary_eqn_Float_Float, a1,  a2)
  157. {
  158.   if (floatval(a1)==floatval(a2))
  159.     return lisptrue;
  160.   else
  161.     return nil;
  162. }
  163. EUFUN_CLOSE
  164.  
  165. EUFUN_1(Md_negate_Float, a1)
  166. {
  167.   return (allocate_float(stacktop,-floatval(a1)));
  168. }
  169. EUFUN_CLOSE
  170.  
  171. /* Primitive operations */
  172. /* Additional Ops */
  173. #define acosh my_acosh
  174. #define asinh my_asinh
  175. #define atanh my_atanh
  176.  
  177.  
  178. static double acosh(double x)
  179. {
  180.   return log(x+sqrt(x*x-1));
  181. }
  182.  
  183. static double asinh(double x)
  184. {
  185.   return log(x+sqrt(x*x+1));
  186. }
  187.  
  188. static double atanh(double x)
  189. {
  190.   return 0.5*(log((x+1.0)/(x-1.0)));
  191. }
  192.  
  193. #ifdef __STDC__
  194. #define PrimOp(op)            \
  195. EUFUN_1(Md_## op ##_Float,x)         \
  196. {                    \
  197.   return allocate_float(stacktop,op(floatval(x)));\
  198. }                    \
  199. EUFUN_CLOSE                \
  200. /*Hack to allow semis */ extern LispObject nil
  201. #else
  202. #define PrimOp(op)            \
  203. EUFUN_1(Md_/**/op/**/_Float,x)        \
  204. {                    \
  205.   return allocate_float(stacktop,op(floatval(x)));\
  206. }                    \
  207. EUFUN_CLOSE                \
  208. /*Hack to allow semis */ extern LispObject nil
  209. #endif
  210.  
  211. PrimOp(sin);
  212. PrimOp(cos);
  213. PrimOp(tan);
  214. PrimOp(asin);
  215. PrimOp(acos);
  216. PrimOp(atan);
  217. PrimOp(log);
  218. PrimOp(log10);
  219. PrimOp(sqrt);
  220. PrimOp(exp);
  221. PrimOp(sinh);
  222. PrimOp(cosh);
  223. PrimOp(tanh);
  224. PrimOp(asinh);
  225. PrimOp(acosh);
  226. PrimOp(atanh);
  227.  
  228. /* XX: 
  229.    Ceiling, Floor, Round, Truncate 
  230.  */
  231.  
  232. EUFUN_1(Md_convert_integer,n)
  233. {
  234.   return (allocate_float(stacktop, (double) intval(n)));
  235. }
  236. EUFUN_CLOSE
  237.  
  238. EUFUN_1(Md_round_float,fl)
  239. {    
  240.   double x=floatval(fl),diff;
  241.   int result;
  242.  
  243.   diff= abs(x - floor(x));
  244.   
  245.   if ( diff== 0.5)
  246.     {
  247.       result=(((int)floor(x)) & 1)==0 ? (int)(floor(x)) : (int) floor(x)+1;
  248.       return allocate_integer(stackbase,result);
  249.     }
  250.   else
  251.     return allocate_integer(stackbase, (int)floor(x + (double) 0.5));
  252. }
  253. EUFUN_CLOSE
  254.  
  255. EUFUN_1(Md_ceiling_float,fl)
  256. {
  257.   return allocate_integer(stacktop, (int) ceil(floatval(fl)));
  258. }
  259. EUFUN_CLOSE
  260.  
  261. EUFUN_1(Md_floor_float,fl)
  262. {
  263.   return allocate_integer(stacktop, (int) floor(floatval(fl)));
  264. }
  265. EUFUN_CLOSE
  266.  
  267.  
  268. /* n-ary operations */
  269. EUFUN_3(Fn_nary_add,n1,n2,lst)
  270. {
  271.   LispObject acc;
  272.  
  273.   acc=generic_apply_2(stacktop,generic_add,n1,n2);
  274.   lst=ARG_2(stackbase);
  275.   while (lst!=nil)
  276.     {
  277.       STACK_TMP(CDR(lst));
  278.       acc=generic_apply_2(stacktop,generic_add,acc,CAR(lst));
  279.       UNSTACK_TMP(lst);
  280.     }
  281.  
  282.   return acc;
  283. }
  284. EUFUN_CLOSE
  285.  
  286. EUFUN_2(Fn_nary_subtract,n1,lst)
  287. {
  288.   LispObject acc;
  289.  
  290.   if (lst==nil)
  291.     return (generic_apply_1(stacktop,generic_negate,n1));
  292.  
  293.   STACK_TMP(CDR(lst));
  294.   acc=generic_apply_2(stacktop,generic_subtract,n1,(CAR(lst)));
  295.   UNSTACK_TMP(lst);
  296.  
  297.   while (lst!=nil)
  298.     {
  299.       STACK_TMP(CDR(lst));
  300.       acc=generic_apply_2(stacktop,generic_subtract,acc,CAR(lst));
  301.       UNSTACK_TMP(lst);
  302.     }
  303.  
  304.   return acc;
  305. }
  306. EUFUN_CLOSE
  307.  
  308. EUFUN_3(Fn_nary_multiply,n1,n2,lst)
  309. {
  310.   LispObject acc;
  311.  
  312.   acc=generic_apply_2(stacktop,generic_multiply,n1,n2);
  313.   lst=ARG_2(stackbase);
  314.   while (lst!=nil)
  315.     {
  316.       STACK_TMP(CDR(lst));
  317.       acc=generic_apply_2(stacktop,generic_multiply,acc,CAR(lst));
  318.       UNSTACK_TMP(lst);
  319.     }
  320.   return acc;
  321. }
  322. EUFUN_CLOSE
  323.  
  324. EUFUN_3(Fn_nary_divide,n1,n2,lst)
  325. {
  326.   LispObject acc;
  327.  
  328.   acc=generic_apply_2(stacktop,generic_divide,n1,n2);
  329.   lst=ARG_2(stackbase);
  330.   while (lst!=nil)
  331.     {
  332.       STACK_TMP(CDR(lst));
  333.       acc=generic_apply_2(stacktop,generic_divide,acc,CAR(lst));
  334.       UNSTACK_TMP(lst);
  335.     }
  336.   return acc;
  337. }
  338. EUFUN_CLOSE
  339.  
  340. EUFUN_3(Fn_nary_gcd,n1,n2,lst)
  341. {
  342.   LispObject acc;
  343.   
  344.   acc=generic_apply_2(stacktop,generic_gcd,n1,n2);
  345.   lst=ARG_2(stackbase);
  346.   while (lst!=nil)
  347.     {
  348.       STACK_TMP(CDR(lst));
  349.       acc=generic_apply_2(stacktop,generic_gcd,acc,CAR(lst));
  350.       UNSTACK_TMP(lst);
  351.     }
  352.   return acc;
  353. }
  354. EUFUN_CLOSE
  355.  
  356. EUFUN_3(Fn_nary_lcm,n1,n2,lst)
  357. {
  358.   LispObject acc;
  359.  
  360.   acc=generic_apply_2(stacktop,generic_lcm,n1,n2);
  361.   lst=ARG_2(stackbase);
  362.   while (lst!=nil)
  363.     {
  364.       STACK_TMP(CDR(lst));
  365.       acc=generic_apply_2(stacktop,generic_lcm,acc,CAR(lst));
  366.       UNSTACK_TMP(lst);
  367.     }
  368.   return acc;
  369. }
  370. EUFUN_CLOSE
  371.  
  372. EUFUN_2(Fn_nary_lt,n1,lst)
  373. {
  374.   while (lst!=nil)
  375.     {
  376.       STACK_TMP(lst);
  377.       if (generic_apply_2(stacktop,generic_lt,n1,CAR(lst))==nil)
  378.     return nil;
  379.  
  380.       UNSTACK_TMP(lst);
  381.       n1=CAR(lst);
  382.       lst=CDR(lst);
  383.     }
  384.   return lisptrue;
  385. }
  386. EUFUN_CLOSE
  387.  
  388. EUFUN_2(Fn_nary_ge,n1,lst)
  389. {
  390.   while (lst!=nil)
  391.     {
  392.       STACK_TMP(lst);
  393.       if (generic_apply_2(stacktop,generic_lt,n1,CAR(lst))!=nil)
  394.     return nil;
  395.  
  396.       UNSTACK_TMP(lst);
  397.       n1=CAR(lst);
  398.       lst=CDR(lst);
  399.     }
  400.   return lisptrue;
  401. }
  402. EUFUN_CLOSE
  403.  
  404. EUFUN_2(Md_remainder_Integer,a, b)
  405. {
  406.   return allocate_integer(stackbase,intval(a)%intval(b));
  407. }
  408. EUFUN_CLOSE
  409.  
  410. EUFUN_2(Fn_nary_le,n1,lst)
  411. {
  412.  
  413.   while (lst!=nil)
  414.     {
  415.       STACK_TMP(lst);
  416.  
  417.       if (generic_apply_2(stacktop,generic_lt,CAR(lst),n1)==lisptrue)
  418.     return nil;
  419.  
  420.       UNSTACK_TMP(lst);
  421.       n1=CAR(lst);
  422.       lst=CDR(lst);
  423.     }
  424.  
  425.   return lisptrue;
  426. }
  427. EUFUN_CLOSE
  428.  
  429. EUFUN_2(Fn_nary_gt,n1,lst)
  430. {
  431.   while (lst!=nil)
  432.     {
  433.       STACK_TMP(lst);
  434.  
  435.       if (generic_apply_2(stacktop,generic_lt,CAR(lst),n1)==nil)
  436.     return nil;
  437.  
  438.       UNSTACK_TMP(lst);
  439.       n1=CAR(lst);
  440.       lst=CDR(lst);
  441.     }
  442.   return lisptrue;
  443. }
  444. EUFUN_CLOSE
  445.  
  446.  
  447. EUFUN_0( Fn_rand)
  448. {
  449.   extern int rand(void);
  450.   int n;
  451.   n=rand();
  452.  
  453.   return(real_allocate_integer(stackbase, n));
  454. }
  455. EUFUN_CLOSE
  456.  
  457. EUFUN_1( Fn_srand, s)
  458. {
  459.   extern void srand(unsigned int);
  460.  
  461.   srand((unsigned int) intval(s));
  462.  
  463.   return(nil);
  464. }
  465. EUFUN_CLOSE
  466.  
  467.  
  468.  
  469. #define ARITH_ENTRIES 59
  470. MODULE Module_arith;
  471. LispObject Module_arith_values[ARITH_ENTRIES];
  472.  
  473. void initialise_arith(LispObject *stacktop)
  474. {
  475.   open_module(stacktop,
  476.           &Module_arith,
  477.           Module_arith_values,
  478.           "arith",
  479.           ARITH_ENTRIES);
  480.  
  481.   generic_add
  482.     = make_module_generic(stacktop,"binary+",2);
  483.   generic_subtract
  484.     = make_module_generic(stacktop,"binary-",2);
  485.   generic_multiply
  486.     = make_module_generic(stacktop,"binary*",2);
  487.   generic_divide
  488.     = make_module_generic(stacktop,"binary/",2);
  489.   generic_lcm
  490.     = make_module_generic(stacktop,"binary-lcm",2);
  491.   generic_gcd
  492.     = make_module_generic(stacktop,"binary-gcd",2);
  493.   generic_lt
  494.     = make_module_generic(stacktop,"binary<",2);
  495.   generic_negate
  496.     = make_module_generic(stacktop,"negate",1);
  497.  
  498.   add_root(&generic_add);
  499.   add_root(&generic_subtract);
  500.   add_root(&generic_multiply);
  501.   add_root(&generic_divide);
  502.   add_root(&generic_lt);
  503.   add_root(&generic_lcm);
  504.   add_root(&generic_gcd);
  505.   add_root(&generic_negate);
  506.  
  507.   (void) make_module_function(stacktop,"binary+_Integer",Md_binary_add_Integer_Integer,2);
  508.   (void) make_module_function(stacktop,"binary-_Integer",Md_binary_subtract_Integer_Integer,2);
  509.   (void) make_module_function(stacktop,"binary*_Integer",Md_binary_multiply_Integer_Integer,2);
  510.   (void) make_module_function(stacktop,"binary/_Integer",Md_binary_divide_Integer_Integer,2);
  511.   (void) make_module_function(stacktop,"binary=_Integer",Md_binary_eqn_Integer_Integer,2);
  512.   (void) make_module_function(stacktop,"binary<_Integer",Md_binary_lt_Integer_Integer,2);
  513.   (void) make_module_function(stacktop,"negate-integer",Md_negate_Integer,1);
  514.  
  515.   (void) make_module_function(stacktop,"binary+_Float",Md_binary_add_Float_Float,2);
  516.   (void) make_module_function(stacktop,"binary-_Float",Md_binary_subtract_Float_Float,2);
  517.   (void) make_module_function(stacktop,"binary*_Float",Md_binary_multiply_Float_Float,2);
  518.   (void) make_module_function(stacktop,"binary/_Float",Md_binary_divide_Float_Float,2);
  519.   (void) make_module_function(stacktop,"binary=_Float",Md_binary_eqn_Float_Float,2);
  520.   (void) make_module_function(stacktop,"binary<_Float",Md_binary_lt_Float_Float,2);
  521.   (void) make_module_function(stacktop,"negate-float",Md_negate_Float,1);
  522.  
  523.   /* Integer Methods */
  524.   (void) make_module_function(stacktop,"binary-lcm-integer",Md_binary_lcm_Integer_Integer,2);
  525.   (void) make_module_function(stacktop,"binary-gcd-integer",Md_binary_gcd_Integer_Integer,2);
  526.   (void) make_module_function(stacktop,"quotient-integer",Md_binary_divide_Integer_Integer,2);
  527.   (void) make_module_function(stacktop,"remainder-integer",Md_remainder_Integer,2);
  528.   (void) make_module_function(stacktop,"modulo-integer",Md_remainder_Integer,2); /* XXX */
  529.   
  530.   /* Float Methods */
  531.   (void) make_module_function(stacktop,"sin-float",Md_sin_Float,1);
  532.   (void) make_module_function(stacktop,"cos-float",Md_cos_Float,1);
  533.   (void) make_module_function(stacktop,"tan-float",Md_tan_Float,1);
  534.   (void) make_module_function(stacktop,"asin-float",Md_asin_Float,1);
  535.   (void) make_module_function(stacktop,"acos-float",Md_acos_Float,1);
  536.   (void) make_module_function(stacktop,"atan-float",Md_atan_Float,1);
  537.   (void) make_module_function(stacktop,"log-float",Md_log_Float,1);
  538.   (void) make_module_function(stacktop,"log10-float",Md_log10_Float,1);
  539.   (void) make_module_function(stacktop,"sqrt-float",Md_sqrt_Float,1);
  540.   (void) make_module_function(stacktop,"exp-float",Md_exp_Float,1);
  541.   (void) make_module_function(stacktop,"sinh-float",Md_sinh_Float,1);
  542.   (void) make_module_function(stacktop,"cosh-float",Md_cosh_Float,1);
  543.   (void) make_module_function(stacktop,"tanh-float",Md_tanh_Float,1);
  544.   (void) make_module_function(stacktop,"asinh-float",Md_asinh_Float,1);
  545.   (void) make_module_function(stacktop,"acosh-float",Md_acosh_Float,1);
  546.   (void) make_module_function(stacktop,"atanh-float",Md_atanh_Float,1);
  547.  
  548.   (void) make_module_function(stacktop,"convert-integer-float",Md_convert_integer,1);
  549.   (void) make_module_function(stacktop,"round-float",Md_round_float,1);
  550.   (void) make_module_function(stacktop,"ceiling-float",Md_ceiling_float,1);
  551.   (void) make_module_function(stacktop,"floor-float",Md_floor_float,1);
  552.  
  553.   (void) make_module_function(stacktop,"+",Fn_nary_add,-3);
  554.   (void) make_module_function(stacktop,"-",Fn_nary_subtract,-2);
  555.   (void) make_module_function(stacktop,"*",Fn_nary_multiply,-3);
  556.   (void) make_module_function(stacktop,"/",Fn_nary_divide,-3);
  557.   (void) make_module_function(stacktop,"gcd",Fn_nary_gcd,-3);
  558.   (void) make_module_function(stacktop,"lcm",Fn_nary_lcm,-3);
  559.  
  560.   (void) make_module_function(stacktop,"<",Fn_nary_lt,-2);
  561.   (void) make_module_function(stacktop,"<=",Fn_nary_le,-2);
  562.   (void) make_module_function(stacktop,">",Fn_nary_gt,-2);
  563.   (void) make_module_function(stacktop,">=",Fn_nary_ge,-2);
  564.  
  565.   (void) make_module_function(stacktop,"c-rand",Fn_rand,0);
  566.   (void) make_module_function(stacktop,"c-srand",Fn_srand,1);
  567.   
  568.   /* Infinities.... */
  569.   /* Most-positive-double-float least-positive-double-float
  570.      most-nagative-double-float least-nagative-double-float
  571.      
  572.      most-positive-fixed-integer
  573.      */
  574.   close_module();
  575. }
  576.